home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / inspect-view.stk < prev    next >
Encoding:
Text File  |  1995-07-19  |  17.2 KB  |  486 lines
  1. ;******************************************************************************
  2. ;
  3. ; Project       : STk-inspect, a graphical debugger for STk.
  4. ;
  5. ; File name     : inspect-view.stk
  6. ; Creation date : Aug-30-1993
  7. ; Last update   : Sep-17-1993
  8. ;
  9. ;******************************************************************************
  10. ;
  11. ; This file implements the different sort of "Viewers".
  12. ;
  13. ;******************************************************************************
  14.  
  15. (provide "inspect-view")
  16.  
  17. (define (view-tl-wid obj) (widget VIEW_WIDGET_NAME (object-symbol obj)))
  18. (define (view-tl-str obj) (& VIEW_WIDGET_NAME (object-symbol obj)))
  19. (define (view-l-wid obj) (widget (view-tl-str obj) ".id.f1.l2"))
  20. (define (view-l-str obj) (& (view-tl-str obj) ".id.f1.l2"))
  21. (define (view-e-wid obj) (widget (view-tl-str obj) ".id.f2.e"))
  22. (define (view-e-str obj) (& (view-tl-str obj) ".id.f2.e"))
  23. (define (view-m-wid obj) (widget (view-tl-str obj) ".menu.command.m"))
  24. (define (view-m-str obj) (& (view-tl-str obj) ".menu.command.m"))
  25. (define (view-c-wid obj) (widget (view-tl-str obj) ".f3.c"))
  26. (define (view-c-str obj) (& (view-tl-str obj) ".f3.c"))
  27.  
  28.  
  29. ;---- Viewer menu -------------------------------------------------------------
  30.  
  31. (define (view-menu-Eval obj)
  32.   (eval-string (format #f "(set! ~a ~a)" obj ((view-e-wid obj) 'get))))
  33.  
  34. (define (view-menu-Quote obj)
  35.   (eval-string (format #f "(set! ~a '~a)" obj ((view-e-wid obj) 'get))))
  36.  
  37. (define (view-menu-Inspect key)
  38.   (let ((obj (find-object-infos key)))
  39.     (inspect obj)
  40.     ((widget (view-tl-str obj) ".menu.command.m") 'disable "Inspect")
  41.     (if (detailed? obj) ((detail-m-wid obj) 'disable "Inspect"))))
  42.  
  43. (define (view-menu-Detail key)
  44.   (let ((obj (find-object-infos key)))
  45.     (detail obj)
  46.     ((widget (view-tl-str obj) ".menu.command.m") 'disable "Detail")
  47.     (if (inspected? obj) ((inspect-m-wid obj) 'disable "Detail"))))
  48.  
  49. (define (view-menu-Unview key) 
  50.   (unview (find-object-infos key)))
  51.  
  52.  
  53. ;---- Viewer ------------------------------------------------------------------
  54.  
  55. (define VIEW_WIDGET_NAME ".viewer")
  56. (define viewed-objects-list ())
  57.  
  58. (define (viewed? obj) (member obj viewed-objects-list))
  59.  
  60. (define (view obj)
  61.   (unless (viewed? obj) (view-object obj)))
  62.  
  63. (define (view-object obj)
  64.   (set! viewed-objects-list (cons obj viewed-objects-list))
  65.   (unless (object-infos obj)
  66.       (add-object-infos obj)
  67.       (if (symbol? obj) (trace-var obj `(update-object ',obj))))
  68.   (view-create obj))
  69.  
  70. (define (unview obj)
  71.   (when (viewed? obj) (unview-object obj)))
  72.  
  73. (define (unview-object obj)
  74.   (let ((top (view-tl-wid obj)))
  75.     (set! viewed-objects-list (list-remove obj viewed-objects-list))
  76.     (if (inspected? obj) ((inspect-m-wid obj) 'enable "View"))
  77.     (if (detailed? obj) ((detail-m-wid obj) 'enable "View"))
  78.     (unless (or (inspected? obj) (detailed? obj))
  79.         (remove-object-infos obj)
  80.         (if (symbol? obj) (untrace-var obj)))
  81.     ;; If toplevel exists (i.e. it is not a <Destroy> event) destroy it
  82.     (if (= (winfo 'exists top) 1)
  83.     (destroy top))))
  84.  
  85. (define (view-create obj)
  86.   (let ((obj-val (inspect::eval obj)))
  87.     (case (inspect::typeof obj-val)
  88.       ((widget)  (when (= (winfo 'exists (view-tl-wid obj-val)) 0)
  89.              (view-widget-create obj-val)))
  90.       ((closure) (view-procedure-create obj))
  91.       (else      (view-object-create obj)))))
  92.  
  93. (define (view-display obj)
  94.   (case (object-type obj)
  95.     ((widget) (view-widget-display (inspect::eval obj)))
  96.     ((closure) (view-procedure-display obj))
  97.     (else (view-object-display obj))))
  98.  
  99.  
  100. ;---- Object/Procedure viewer -------------------------------------------------
  101.  
  102. (define CAR_COLOR "gray90")
  103. (define CDR_COLOR "gray70")
  104. (define ARROW_COLOR "black")
  105. (define TEXT_COLOR "black")
  106.  
  107. (define (highlightItem canvas color1 color2)
  108. (let ((item (car (canvas 'find 'withtag 'current))))
  109.     (if (equal? (tki-get canvas item :fill) color1)
  110.     (tki-set canvas item :fill color2)
  111.     (tki-set canvas item :fill color1))))
  112.  
  113. (define (find-car/cdr fct count l)
  114.   (define (_find-car/cdr fct count l path)
  115.     (if (not (pair? l))
  116.     (if (null? path)
  117.         #f
  118.         (_find-car/cdr fct count (caar path) (cdr path)))
  119.     (if (equal? 0 count)
  120.         (fct l)
  121.         (_find-car/cdr fct (- count 1) (cdr l) (cons l path)))))
  122.   (_find-car/cdr fct count l ()))
  123.  
  124. (define (double1OnCar obj)
  125.   (let* ((canvas (view-c-wid obj))
  126.      (item (car (canvas 'find 'withtag 'current)))
  127.      (cars (canvas 'find 'withtag 'CAR)))
  128.     (view (find-car/cdr car (list-first item cars) (inspect::eval obj)))))
  129.  
  130. (define (double1OnCdr canvas obj)
  131.   (let ((item (car (canvas 'find 'withtag 'current)))
  132.     (cdrs (canvas 'find 'withtag 'CDR)))
  133.     (view (find-car/cdr cdr (list-first item cdrs) (inspect::eval obj)))))
  134.  
  135. (define (text-width text font)
  136.   (canvas ".text-width")
  137.   (define bbox
  138.     (.text-width 'bbox (.text-width 'create 'text 0 0 :text text :font font)))
  139.   (destroy .text-width)
  140.   (- (caddr bbox) (car bbox)))
  141.  
  142. (define (view-create-toplevel obj)
  143.   (define w (create-toplevel-widget (view-tl-str obj)))
  144.   (define id-w (widget w ".id"))
  145.   (set-id-label1 id-w "Object" 6)
  146.   (set-id-label2 id-w "Value" 6)
  147.  
  148.   (define menu-w (widget w ".menu"))
  149.   ((widget w ".menu.help.m") 'add 'command :label "Viewer"
  150.                  :command '(stk:make-help Viewer-help))
  151.   (pack [menubutton (& menu-w ".command") :text "Command"] :side "left")
  152.   (define cmd-w (eval [menu (& menu-w ".command.m")]))
  153.   (tk-set! (widget menu-w ".command") :menu cmd-w)
  154.   (cmd-w 'add 'command :label "Inspect" 
  155.                 :command `(view-menu-Inspect ',(object-symbol obj)))
  156.   (if (inspected? obj) (cmd-w 'disable "Inspect"))
  157.   (cmd-w 'add 'command :label "Detail" 
  158.              :command `(view-menu-Detail ',(object-symbol obj)))
  159.   (if (detailed? obj) (cmd-w 'disable "Detail"))
  160.   (cmd-w 'add 'command :label "Unview" 
  161.                 :command `(view-menu-Unview ',(object-symbol obj)))
  162.  
  163.   (if (modifiable-object? obj)
  164.       [begin
  165.     (bind (widget w ".id.f2.e") "<Return>" `(view-menu-Eval ',obj))
  166.     (bind (widget w ".id.f2.e") "<Shift-Return>" `(view-menu-Quote ',obj))]
  167.       [begin
  168.     ((view-e-wid obj) 'insert 0 (format #f "~S" (inspect::eval obj)))
  169.     (inspect::shadow-entry (widget w ".id.f2.e"))])
  170.  
  171.  
  172.   (pack [frame (& w ".f3") :relief "sunken" :bd 2]
  173.     :fill "both" :expand "yes" :padx 4 :pady 2)
  174.   (pack [scrollbar (& w ".f3.vsb") :orient "vertical"]
  175.     :side "left" :fill "y")
  176.   (pack [scrollbar (& w ".f3.hsb") :orient "horizontal"]
  177.     :side "bottom" :fill "x")
  178.   (pack [canvas (view-c-str obj) :relief "raised" :bd 2]
  179.     :fill "both" :expand "yes")
  180.   (tk-set! (widget w ".f3.vsb") :command (& (view-c-str obj) " 'yview"))
  181.   (tk-set! (widget w ".f3.hsb") :command (& (view-c-str obj) " 'xview"))
  182.   (tk-set! (view-c-wid obj) :yscroll (& w ".f3.vsb 'set"))
  183.   (tk-set! (view-c-wid obj) :xscroll (& w ".f3.hsb 'set"))
  184.   (bind w "<Destroy>" `(view-menu-Unview ',(object-symbol obj)))
  185.   w)
  186.  
  187. (define (view-object/procedure-create obj)
  188.   (define w (view-create-toplevel obj))
  189.   (wm 'title w "Object viewer")
  190.   (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  191.   (define c (view-c-wid obj))
  192.   (define c-name (widget-name c))
  193.   (c 'bind 'CAR "<Enter>" `(highlightItem ,c-name CAR_COLOR "red"))
  194.   (c 'bind 'CAR "<Leave>" `(highlightItem ,c-name CAR_COLOR "red"))
  195.   (c 'bind 'CAR "<Double-1>" `(double1OnCar ',obj))
  196.   (c 'bind 'CDR "<Enter>" `(highlightItem ,c-name CDR_COLOR "blue"))
  197.   (c 'bind 'CDR "<Leave>" `(highlightItem ,c-name CDR_COLOR "blue"))
  198.   (c 'bind 'CDR "<Double-1>" `(double1OnCdr ,c-name ',obj))
  199.   w)
  200.  
  201. (define (view-object-create obj)
  202.   (define w (view-object/procedure-create obj))
  203.   (view-object-display obj))
  204.  
  205. (define (view-object-display obj)
  206.   (wm 'title  (view-tl-wid obj) "Object viewer")
  207.   (define obj-val (inspect::eval obj))
  208.   (tk-set! (view-l-wid obj) :text (->object obj))
  209.   ((view-e-wid obj) 'delete 0 'end)
  210.   ((view-e-wid obj) 'insert 0 (->object obj-val))
  211.   (view-object/procedure-display (view-c-wid obj) obj-val)) 
  212.  
  213. (define (view-procedure-create obj)
  214.   (define w (view-object/procedure-create obj))
  215.   (view-procedure-display obj))
  216.  
  217. (define (view-procedure-display obj)
  218.   (wm 'title  (view-tl-wid obj) "Procedure viewer")
  219.   (define obj-val (inspect::eval obj))
  220.   (tk-set! (view-l-wid obj) :text (->object obj))
  221.   ((view-e-wid obj) 'delete 0 'end)
  222.   ((view-e-wid obj) 'insert 0 (->object obj-val))
  223.   (view-object/procedure-display (view-c-wid obj) (procedure-body obj-val)))
  224.  
  225. (define (view-object/procedure-display c obj-val)
  226.   (define grid-h 60) ; horizontal spacing between grid lines
  227.   (define grid-v 40) ; vertical spacing between grid lines
  228.   (define cons-h 40) ; horizontal size of cons cell
  229.   (define cons-v 20) ; vertical size of cons cell
  230.   (define cons-h/2 (quotient cons-h 2))
  231.   (define cons-v/2 (quotient cons-v 2))
  232.   (define arrow-space 2) ; space between arrow and box
  233.   (define (x-h x) (* x grid-h))
  234.   (define (y-v y) (* y grid-v))
  235.   (define font "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
  236.  
  237.   (define (draw-cons-cell x y)
  238.     (let ((h (x-h x)) (v (y-v y)))
  239.       (c 'create 'rectangle h v (+ h cons-h/2 1) (+ v cons-v)
  240.      :fill CAR_COLOR :tag 'CAR)
  241.       (c 'create 'rectangle (+ h cons-h/2) v (+ h cons-h) (+ v cons-v)
  242.      :fill CDR_COLOR :tag 'CDR)))
  243.  
  244.   (define (car-arrow-pos x y d)
  245.     (let ((h (x-h x)) (v (y-v y)))
  246.       (list (+ h (quotient cons-h 4)) (+ v cons-v/2) (+ h (quotient cons-h 4))
  247.         (+ v cons-v/2 (- (* d grid-v) (+ cons-v/2 arrow-space))))))
  248.  
  249.   (define (draw-car-arrow x y d) ; draw arrow downwards 'd' grid squares
  250.     (let ((pos (car-arrow-pos x y d)))
  251.       (if (and (= x 0) (= y 0))
  252.       (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"))
  253.       (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"
  254.              :tag 'CAR_ARROW)))))
  255.  
  256.   (define (draw-car-text x y d text)
  257.     (let ((pos (car-arrow-pos x y d)))
  258.       (if (<= (text-width text font) grid-h)
  259.       (c 'create 'text (caddr pos) (cadddr pos)
  260.          :anchor "n" :font font :text text :tag 'CAR_TEXT)
  261.       (let* ((text-l [label (& c "." (gensym "__g"))
  262.                 :relief "groove" :bd 2
  263.                 :text text :anchor "w" :font font])
  264.          (item (c 'create 'window (caddr pos) (+ 2 (cadddr pos))
  265.               :window text-l :anchor "n" :width (- grid-h 2)
  266.               :tags 'LONG_CAR_TEXT)))
  267.         (bind text-l "<Enter>" 
  268.           `(,(widget-name c) 'itemconfig ,item
  269.                      :width ,(+ 3 (text-width text font))))
  270.         (bind text-l "<Leave>" 
  271.           `(,(widget-name c) 'itemconfig ,item
  272.                      :width ,(- grid-h 2)))))))
  273.  
  274.   (define (cdr-arrow-pos x y d)
  275.     (let ((h (x-h x)) (v (y-v y)))
  276.       (list (+ h (quotient (* cons-h 3) 4)) (+ v cons-v/2)
  277.         (+ h (quotient (* cons-h 3) 4)
  278.            (- (* d grid-h) (+ (quotient (* cons-h 3) 4) arrow-space)))
  279.         (+ v cons-v/2))))
  280.   
  281.   (define (draw-cdr-arrow x y d) ; draw arrow to the right 'd' grid squares
  282.     (let ((pos (cdr-arrow-pos x y d)))
  283.       (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"
  284.          :tag 'CDR_ARROW))))
  285.  
  286.   (define (draw-cdr-text x y d text)
  287.     (let ((pos (cdr-arrow-pos x y d)))
  288.       (c 'create 'text (caddr pos) (cadddr pos)
  289.      :anchor "w" :font font :text text :tag 'CDR_TEXT)))
  290.  
  291.   (define (draw-nil x y) ; draw nil in cdr of cons cell
  292.     (let ((h (x-h x)) (v (y-v y)))
  293.       (c 'create 'line (+ h cons-h/2) v (+ h cons-h) (+ v cons-v))
  294.       (c 'create 'line (+ h cons-h/2) (+ v cons-v -1) (+ h cons-h) (- v 1))))
  295.  
  296.   (define (object-length obj-val)
  297.     (cond ((null? obj-val) 0)
  298.       ((pair? obj-val) (+ 1 (object-length (cdr obj-val))))
  299.       (else (+ 1 (quotient (text-width (->object obj-val) font)
  300.                  grid-h)))))
  301.     
  302.   (define (initial-profile) 0)
  303.   (define (car-profile p) (if (pair? p) (car p) p))
  304.   (define (cdr-profile p) (if (pair? p) (cdr p) p))
  305.  
  306.   (define (make-profile len p)
  307.     (define (fit1 len p)
  308.       (if (> len 1)
  309.       (let ((p* (fit1 (- len 1) (cdr-profile p))))
  310.         (cons (car-profile p*) p*))
  311.       (fit2 (+ (car-profile p) 1) p)))
  312.     (define (fit2 y p)
  313.       (if (pair? p)
  314.       (cons (max y (car-profile p)) (fit2 y (cdr-profile p)))
  315.       (max y p)))
  316.     (fit1 len p))
  317.  
  318.   (define (draw-list lst x y p)
  319.     (draw-cons-cell x y)
  320.     (let* ((tail (cdr lst))
  321.        (tail-p (cdr-profile p))
  322.        (new-p (cond ((null? tail)
  323.              (draw-nil x y)
  324.              tail-p)
  325.             ((pair? tail)
  326.              (draw-cdr-arrow x y 1)
  327.              (draw-list tail (+ x 1) y tail-p))
  328.             (else
  329.              (draw-cdr-arrow x y 1)
  330.              (draw-cdr-text x y 1 (->object tail))
  331.              tail-p))))
  332.       (draw-object (car lst) x y (cons (car-profile p) new-p))))
  333.  
  334.   (define (draw-object obj-val x y p)
  335.     (if (pair? obj-val)
  336.         (let* ((len (object-length obj-val))
  337.            (new-p (make-profile len p))
  338.            (yy (car-profile new-p)))
  339.       (draw-car-arrow x y (- yy y))
  340.       (draw-list obj-val x yy new-p))
  341.     (let ((text (->object obj-val)))
  342.           (draw-car-arrow x y 1)
  343.       (draw-car-text x y 1 text)
  344.           (make-profile 1 p))))
  345.  
  346.   (c 'delete 'all)
  347.   (draw-object obj-val 0 0 (initial-profile))
  348.   (adjust-scrollregion c 20))
  349.  
  350.  
  351. ;---- Widget viewer -----------------------------------------------------------
  352.  
  353. (define show-widget
  354.   (let ((bg-color ())
  355.     (box-color ()))
  356.     (lambda (obj item press)
  357.       (let* ((canv-w (view-c-wid (inspect::eval obj)))
  358.          (tags (canv-w 'gettags item))
  359.          (wid (inspect::eval (list-ref tags 1))))
  360.     (if press
  361.         (begin
  362.           (set! box-color (tki-get canv-w item :fill))
  363.           (set! bg-color (tk-get wid :bg))
  364.           (tki-set canv-w item :fill "magenta")
  365.           (tk-set! wid :bg "magenta"))
  366.         (begin
  367.           (tki-set canv-w item :fill box-color)
  368.           (tk-set! wid :bg bg-color)))))))
  369.  
  370. (define (inspect-sub-widget obj who)
  371.   (catch 
  372.    (inspect (inspect::eval (list-ref ((view-c-wid obj) 'gettags who) 1)))))
  373.  
  374. (define (view-widget-create obj)
  375.   (define w (view-create-toplevel obj))
  376.   (define obj-val (inspect::eval obj))
  377.   (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  378.   (pack [frame (& w ".menu.level")] :side "left")
  379.   (pack [label (& w ".menu.level.l") :text "Level"] :side "left")
  380.   (pack [entry (& w ".menu.level.e") :relief "sunken" :bd 2 :width 4]
  381.     :side "left")
  382.   ((widget w ".menu.level.e") 'insert 0 9999)
  383.   (bind (widget (view-tl-str obj) ".menu.level.e") "<Return>"
  384.     `(view-widget-modify-level ',(object-symbol obj)))
  385.  
  386.   (define c (view-c-wid obj))
  387.   (c 'bind '|CLASS| "<Double-1>" 
  388.      `(inspect-sub-widget ,(widget-name obj-val) 
  389.               'current))
  390.   (c 'bind '|CLASS_NAME| "<Double-1>" 
  391.      `(inspect-sub-widget ,(widget-name obj-val) 
  392.               (car (,(widget-name c) 'find 'below 'current))))
  393.  
  394.   (c 'bind '|CLASS| "<ButtonPress-1>" 
  395.                  `(show-widget ,(widget-name obj-val) 'current #t))
  396.   (c 'bind '|CLASS| "<ButtonRelease-1>" 
  397.             `(show-widget ,(widget-name obj-val) 'current #f))
  398.   (c 'bind '|CLASS_NAME| "<ButtonPress-1>"
  399.      `(show-widget ,(widget-name obj-val)
  400.            (car (,(widget-name c) 'find 'below 'current)) #t))
  401.   (c 'bind '|CLASS_NAME| "<ButtonRelease-1>"
  402.      `(show-widget ,(widget-name obj-val) 
  403.            (car (,(widget-name c) 'find 'below 'current)) #f))
  404.   (view-widget-display obj))
  405.  
  406. (define (view-widget-set-level obj level)
  407.   ((widget (view-tl-str obj) ".menu.level.e") 'delete 0 'end)
  408.   ((widget (view-tl-str obj) ".menu.level.e") 'insert 0 level))
  409.  
  410. (define (view-widget-get-level obj)
  411.   (let ((level ((widget (view-tl-str obj) ".menu.level.e") 'get)))
  412.     (if (equal? "" level) 9999 (string->number level))))
  413.  
  414. (define (view-widget-modify-level key)
  415.   (let ((obj (find-object-infos key)))
  416.     (unless (view-widget-get-level obj) (view-widget-set-level obj 9999))
  417.     (view-widget-clear obj)
  418.     (view-widget-display obj)))
  419.  
  420. (define (get-children wid)
  421.   (let ((children (winfo 'children wid)))
  422.     (if (list? children) children (list children))))
  423.  
  424. (define (view-widget-clear obj) ((view-c-wid obj) 'delete 'all))
  425.  
  426. (define (view-widget-display obj)
  427.   (wm 'title (view-tl-wid obj) "Widget viewer")
  428.   (define obj-wid obj)
  429.   (define canv (view-c-wid obj))
  430.   (define h-grid 60)
  431.   (define v-grid 40)
  432.   (define h-box 80) (define h-box/2 (/ h-box 2))
  433.   (define v-box 20) (define v-box/2 (/ v-box 2))
  434.   (define y-global 40)
  435.   (define level (view-widget-get-level obj))
  436.   (define level-min level)
  437.   (define (_display wid x level)
  438.     (let* ((name (winfo 'name wid))
  439.        (class (winfo 'class wid))
  440. ;       (children (winfo 'children wid))
  441.        (children (get-children wid))
  442.        (y y-global))
  443.       (canv 'create 'rectangle (- x h-box/2) (- y v-box) (+ x h-box/2) y 
  444.         :fill "gray90" :tags (format #f "CLASS ~a" (->string wid)))
  445.       (canv 'create 'text x (- y v-box/2)
  446.         :anchor "center" :text class :font HELVETICA_MO12 
  447.         :tags "CLASS_NAME")
  448.       (canv 'create 'text (+ x h-box/2 10) (- y v-box/2)
  449.         :anchor "w" :text name :font HELVETICA_BR12)
  450.       (if (null? children)
  451.       (set! level-min (min level level-min))
  452.       (if (> level 0)
  453.           (let ((y-child y))
  454.         (for-each
  455.          (lambda (child)
  456.            (set! y-global (+ y-global v-grid))
  457.            (set! y-child y-global)
  458.            (_display child (+ x h-grid) (- level 1)))
  459.          children)
  460.         (canv 'create 'line x y x (- y-child v-box/2)))
  461.           (begin
  462.         (set! level-min 0)
  463.         (canv 'create 'line x y x (+ y v-box/2) :stipple "gray50"))))
  464.       (unless (equal? obj-wid wid)
  465.           (canv 'create 'line 
  466.             (- x h-box/2) (- y v-box/2) (- x h-grid) (- y v-box/2)))))
  467.  
  468.   (set-id-object (& (view-tl-str obj) ".id") (format #f "~S" obj))
  469.   (set-id-value (& (view-tl-str obj) ".id") (format #f "~S" (inspect::eval obj)))
  470.   ((view-c-wid obj) 'delete 'all)
  471.   (_display obj-wid 0 level)
  472.   (view-widget-set-level obj (- level level-min))
  473.   (adjust-scrollregion canv 20))
  474.  
  475. (define (adjust-scrollregion canv offset)
  476.   (multiple-value-bind (x1 y1 x2 y2) (canv 'bbox 'all)
  477.                (tk-set! canv :scrollregion
  478.                 (&& (- x1 offset) (- y1 offset)
  479.                     (+ x2 offset) (+ y2 offset))))
  480.   (canv 'xview 0)
  481.   (canv 'yview 0))
  482.  
  483. (define (view-widget obj)
  484.   (view-widget-create obj)
  485.   (view-widget-display obj))
  486.